(defconst fp-params
  '((:name QFP-144 :type QFP :pins 144 :width 21.4 :pitch 0.5 :pad-size-x 1.5 :pad-size-y 0.3 :body-width 20.0)
    (:name QFP-64-10x10 :type QFP :pins 64 :width 11.4 :pitch 0.5 :pad-size-x 1.5 :pad-size-y 0.3 :body-width 10.0)
    (:name QFN-48-7x7 :type QFN :pins 48 :width 7.0 :pitch 0.5 :pad-size-x 0.8 :pad-size-y 0.24 :body-width 7.0 :flag-width 4.2 :shape oval :flag-paste-ratio 0.75)
    (:name QFN-48-6x6 :type QFN :pins 48 :width 6.0 :pitch 0.4 :pad-size-x 0.8 :pad-size-y 0.2 :body-width 6.0 :flag-width 4.8 :shape oval :flag-paste-ratio 0.5)
    (:name QFN-32-5x5 :type QFN :pins 32 :width 5.0 :pitch 0.5 :pad-size-x 0.8 :pad-size-y 0.3 :body-width 5.0 :flag-width 3.8 :shape oval :flag-paste-ratio 0.5)
    (:name QFN-24-4x4 :type QFN :pins 24 :width 4.0 :pitch 0.5 :pad-size-x 0.8 :pad-size-y 0.3 :body-width 4.0 :flag-width 2.25 :shape oval :flag-paste-ratio 0.5)
    (:name VBGA60 :type BGA :pins 60 :width-x 6.4 :width-y 7.2 :pitch 0.8 :pad-size 0.35 :body-width-x 8.0 :body-width-y 9.0 :pins-x 9 :gap-x (4 6) :courtyard 1.0)))

(defconst fp-type-params
  '((QFP . (:header fp-qf-header :pad fp-qf-pad))
    (QFN . (:header fp-qf-header :pad fp-qf-pad))
    (BGA . (:header fp-bga-header :pad fp-bga-pad))))

(defun fp-qf-pad-coord (attrs num-1)
  (let* ((num (- num-1 1))
         (pins (plist-get attrs :pins))
         (width (plist-get attrs :width))
         (pitch (plist-get attrs :pitch))

         (half-width (/ width 2))
         (per-side (/ pins 4))
         (pad-ofs (/ (- width (* pitch (- per-side 1)))
                     2))

         (num-mod (mod num per-side))
         (side (/ num per-side))
         (angle (if (= (mod side 2) 1)
                    90
                  0))
         (pos (* num-mod pitch))
         (x (case side
              (0 0)
              (1 (+ pos pad-ofs))
              (2 width)
              (3 (- width pad-ofs pos))))
         (y (case side
              (0 (+ pos pad-ofs))
              (1 width)
              (2 (- width pad-ofs pos))
              (3 0)))
         (x (- x half-width))
         (y (- y half-width)))
    (list x y angle)))

(defun fp-qf-pad (attrs num-1)
  (let* ((shape (or (plist-get attrs :shape) 'rect))
         (pad-size-x (plist-get attrs :pad-size-x))
         (pad-size-y (plist-get attrs :pad-size-y))

         (xy (fp-qf-pad-coord attrs num-1))
         (x (nth 0 xy))
         (y (nth 1 xy))
         (angle (nth 2 xy)))
    `(pad ,num-1 smd ,shape
          (at ,x ,y ,angle)
          (size ,pad-size-x ,pad-size-y)
          (layers F.Cu F.Paste F.Mask))))

(defun fp-plot-corner (in-x in-y out-x out-y xo yo &optional size)
  (let ((size (or size 0.15)))
    `((fp_line (start ,(funcall xo out-x) ,(funcall yo in-y))
               (end ,(funcall xo out-x) ,(funcall yo out-y))
               (layer F.SilkS) (width ,size))
      (fp_line (start ,(funcall xo in-x) ,(funcall yo out-y))
               (end ,(funcall xo out-x) ,(funcall yo out-y))
               (layer F.SilkS) (width ,size)))))

(defun fp-plot-courtyard (max-x max-y &optional space layer width)
  (let* ((layer (or layer 'F.CrtYd))
         (space (or space 0.25))
         (width (or width 0.05))
         (x (+ max-x space))
         (y (+ max-y space)))
    `((fp_line (start ,(- x) ,(- y))
               (end ,(- x) ,y)
               (layer ,layer) (width ,width))
      (fp_line (start ,(- x) ,y)
               (end ,x ,y)
               (layer ,layer) (width ,width))
      (fp_line (start ,x ,y)
               (end ,x ,(- y))
               (layer ,layer) (width ,width))
      (fp_line (start ,x ,(- y))
               (end ,(- x) ,(- y))
               (layer ,layer) (width ,width)))))

(defun fp-plot-pin1-pointer (tip-x tip-y)
  `((fp_line (start ,tip-x ,tip-y) (end ,(+ tip-x -0.75) ,(+ tip-y -0.95)) (layer F.SilkS) (width 0.15))
    (fp_line (start ,tip-x ,tip-y) (end ,(+ tip-x -0.95) ,(+ tip-y -0.75)) (layer F.SilkS) (width 0.15))
    (fp_line (start ,(+ tip-x -1.025) ,(+ tip-y -0.675)) (end ,(+ tip-x -0.675) ,(+ tip-y -1.025)) (layer F.SilkS) (width 0.15))
    (fp_line (start ,(+ tip-x -0.675) ,(+ tip-y -1.025)) (end ,tip-x ,tip-y) (layer F.SilkS) (width 0.15))
    (fp_line (start ,tip-x ,tip-y) (end ,(+ tip-x -1.025) ,(+ tip-y -0.675)) (layer F.SilkS) (width 0.15))
    (fp_line (start ,tip-x ,tip-y) (end ,(+ tip-x -0.85) ,(+ tip-y -0.85)) (layer F.SilkS) (width 0.15))))

(defun fp-plot-pin1-circle (x y)
  `(fp_circle (center ,x ,y) (end ,(+ x 0.125) ,y) (layer F.SilkS) (width 0.25)))

(defun fp-plot-flag-paste (attrs)
  (let* ((flag-width (plist-get attrs :flag-width))
         (rounded-radius 0.075)
         (reduced-width (* flag-width (sqrt (plist-get attrs :flag-paste-ratio))))
         (min-gap 0.3)
         (gap-count (floor (/ (- flag-width reduced-width) min-gap)))
         (pad-count (1+ gap-count))
         (paste-width (/ reduced-width pad-count))
         (rounded-ratio (/ rounded-radius paste-width))
         (total-gap-width (- flag-width reduced-width))
         (single-gap-width min-gap)
         (edge-width (- total-gap-width (* single-gap-width gap-count)))
         (paste-pitch (+ single-gap-width paste-width))
         (paste-start (/ (- flag-width edge-width paste-width) 2))
         (pastes (loop for x from 0 to gap-count
                       for x-pos = (- (* x paste-pitch) paste-start)
                       append
                       (loop for y from 0 to gap-count
                             for y-pos = (- (* y paste-pitch) paste-start)
                             collect
                             `(pad FLAG smd roundrect
                                   (at ,x-pos ,y-pos)
                                   (size ,paste-width ,paste-width)
                                   (layers F.Cu F.Paste)
                                   (zone_connect 0)
                                   (roundrect_rratio ,rounded-ratio))))))
    pastes))

(defun fp-plot-flag (attrs)
  (let* ((via-width (- (plist-get attrs :flag-width) 0.5 0.5))
         (via-max (floor (/ via-width 1.2)))
         (via-start (* (/ via-max 2.0) 1.2))
         (vias (loop for x from 0 to via-max
                     for xpos = (- (* x 1.2) via-start)
                     append
                     (loop for y from 0 to via-max
                           for ypos = (- (* y 1.2) via-start)
                           collect
                           `(pad FLAG thru_hole circle
                                 (at ,xpos ,ypos)
                                 (size 0.3 0.3)
                                 (drill 0.3)
                                 (layers *.Cu)
                                 (zone_connect 2)))))
         (rounded-radius 0.1)
         (copper `(pad FLAG smd roundrect
                       (at 0 0)
                       (size ,(plist-get attrs :flag-width) ,(plist-get attrs :flag-width))
                       (layers F.Cu F.Mask)
                       (zone_connect 0)
                       (roundrect_rratio ,(/ rounded-radius (plist-get attrs :flag-width)))))
         (pastes (fp-plot-flag-paste attrs)))
    (append (list copper) vias pastes)))

(defun fp-qf-header (attrs)
  (let* ((font-data '((layer F.SilkS)
                      (effects (font (size 0.7 0.7) (thickness 0.15)))))
         (pins-per-side (/ (plist-get attrs :pins) 4))
         (silk-len (- (/ (- (plist-get attrs :body-width)
                            (* (plist-get attrs :pitch)
                               (- pins-per-side 1))
                            (plist-get attrs :pad-size-y))
                        2)
                     0.25))
        (body-edge (/ (plist-get attrs :body-width) 2))
        (silk-edge (- body-edge silk-len))
        (courtyard-edge (+ (/ (+ (plist-get attrs :width)
                                 (plist-get attrs :pad-size-x))
                              2)))
        (body-edge-x (/ (+ (plist-get attrs :width)
                          (plist-get attrs :pad-size-x))
                       2))
        (body-edge-y (* (- pins-per-side 1)
                       (plist-get attrs :pitch)
                       0.5)))
    `((attr smd)
      (layer F.Cu)
      (at 0 0)
      (fp_text reference ,(plist-get attrs :name)
               (at 0 -1)
               ,@font-data)
      (fp_text value VAL**
               (at 0 1)
               ,@font-data)
      ,@(fp-plot-corner silk-edge silk-edge body-edge body-edge '- '-)
      ,@(fp-plot-corner silk-edge silk-edge body-edge body-edge '- '+)
      ,@(fp-plot-corner silk-edge silk-edge body-edge body-edge '+ '-)
      ,@(fp-plot-corner silk-edge silk-edge body-edge body-edge '+ '+)
      ;; mark pin 1
      (fp_line (start ,(- body-edge) ,(- silk-edge))
               (end ,(- silk-edge) ,(- body-edge))
               (layer F.SilkS) (width 0.15))
      ;; ,(let ((xy (fp-qf-pad-coord attrs 1)))
      ;;    (fp-plot-pin1-circle (- 0 body-edge-x 0.5) (nth 1 xy)))
      ,@(fp-plot-courtyard courtyard-edge courtyard-edge)
      ,@(fp-plot-courtyard courtyard-edge courtyard-edge nil 'F.Fab 0.1)
      (fp_text user %R (at 0 0) (layer F.Fab) (effects (font (size 1.5 1.5) (thickness 0.15))))
      ;; optional flag
      ,@(when (eq 'QFN (plist-get attrs :type))
          `(,@(fp-plot-flag attrs)
            ,@(fp-plot-corner silk-edge silk-edge (+ body-edge 0.3) (+ body-edge 0.3) '- '- 0.2))
          ;; XXX paste missing
          ))))

(defun fp-bga-header (attrs)
  (let* ((font-data '((layer F.SilkS)
                      (effects (font (size 0.7 0.7) (thickness 0.15)))))
         (body-edge-x (/ (plist-get attrs :body-width-x) 2))
         (body-edge-y (/ (plist-get attrs :body-width-y) 2))
         (silk-edge-x (/ (plist-get attrs :width-x) 2))
         (silk-edge-y (/ (plist-get attrs :width-y) 2))
         (courtyard (or (plist-get attrs :courtyard) 1.0)))
    `((attr smd)
      (layer F.Cu)
      (at 0 0)
      (fp_text reference ,(plist-get attrs :name)
               (at 0 -1)
               ,@font-data)
      (fp_text value VAL**
               (at 0 1)
               ,@font-data)
      ,@(fp-plot-corner silk-edge-x silk-edge-y body-edge-x body-edge-y '- '-)
      ,@(fp-plot-corner silk-edge-x silk-edge-y body-edge-x body-edge-y '- '+)
      ,@(fp-plot-corner silk-edge-x silk-edge-y body-edge-x body-edge-y '+ '-)
      ,@(fp-plot-corner silk-edge-x silk-edge-y body-edge-x body-edge-y '+ '+)
      ;; mark pin 1
      (fp_line (start ,(- body-edge-x) ,(- silk-edge-y))
               (end ,(- silk-edge-x) ,(- body-edge-y))
               (layer F.SilkS) (width 0.15))
      ,@(fp-plot-pin1-pointer (- 0 body-edge-x 0.5) (- 0 body-edge-y 0.5))
      ,@(fp-plot-courtyard body-edge-x body-edge-y courtyard))))

(defun fp-bga-pad (attrs num-1)
  (let* ((num (- num-1 1))
         (pitch (plist-get attrs :pitch))
         (diam (plist-get attrs :pad-size))
         (width-x (plist-get attrs :width-x))
         (width-y (plist-get attrs :width-y))
         (row-names (or (plist-get attrs :row-names) "ABCDEFGHJKLMNPRSTUWXYZ"))
         (gap-x (plist-get attrs :gap-x))
         (gap-y (plist-get attrs :gap-y))
         (per-row (plist-get attrs :pins-x))
         (per-row (if gap-x
                      (- per-row (- (nth 1 gap-x) (nth 0 gap-x)) 1)
                    per-row))
         (xnum (mod num per-row))
         (ynum (/ num per-row))
         ;; gap is defined 1-based
         (xnum (if (and gap-x (>= (+ xnum 1) (nth 0 gap-x)))
                   (+ xnum (- (nth 1 gap-x) (nth 0 gap-x)) 1)
                 xnum))
         (ynum (if (and gap-y (>= (+ ynum 1) (nth 0 gap-y)))
                   (+ ynum (- (nth 1 gap-y) (nth 0 gap-y)) 1)
                 ynum))
         (yname (char-to-string (elt row-names ynum)))
         (padname (make-symbol (format "%s%s" yname (+ xnum 1))))
         (xpos (* xnum pitch))
         (ypos (* ynum pitch))
         (xpos (- xpos (/ width-x 2)))
         (ypos (- ypos (/ width-y 2))))
    `(pad ,padname smd circle (at ,xpos ,ypos) (size ,diam ,diam) (layers F.Cu F.Paste F.Mask))))

(defun fp-draw (fp &rest opts)
  (let* ((attrs (car (delq nil (mapcar (lambda (a)
                                         (when (eq (plist-get a :name) fp)
                                           a))
                                       fp-params))))
         (attrs (append opts attrs))
         (funs (cdr (assoc (plist-get attrs :type) fp-type-params)))
         (header-fun (plist-get funs :header))
         (pad-fun (plist-get funs :pad))
         (data (funcall header-fun attrs))
         (fp-name (or (plist-get attrs :name) fp)))
    (dotimes (pin-0 (plist-get attrs :pins))
      (let ((pin-1 (+ pin-0 1)))
        (add-to-list 'data (funcall pad-fun attrs pin-1) t)))
    (insert (format "# created with %s\n" (append `(fp-draw ',fp) opts)))
    (insert (format "(module %s\n" fp-name))
    (dolist (e data)
      (princ e (current-buffer))
      (insert "\n"))
    (insert ")\n")))
